The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpb4_src.zip/EXTRACT.PAS

Pascal/Delphi Source File | 1988-09-13 | 6KB | 211 lines

{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault

  Last modified  ::  3-4-88 9:46 pm
}

{$R-}                             {Range checking off}
{$B-}                             {Boolean complete evaluation off}
{$S-}                             {Stack checking off}
{$I+}                             {I/O checking on}
{$N-}                             {No numeric coprocessor}

Unit Extract;

Interface

Uses
  TPCrt, Dos, Globals, Core1, Core2;


function Read_Arc_Hdr : Boolean;

procedure ExtractArc(var XfrName : DosFileName; var ok_to_send : Boolean);

procedure ExtractLbr(var XfrName : DosFileName; remaining : LongInt;
                     var ok_to_send  : Boolean);


  {==========================================================================}


Implementation


  function Read_Arc_Hdr : Boolean;
    { read a file header from the archive file }
    { FALSE = eof found; TRUE = header found }

  var
    bt              : Byte;
    OK              : Boolean;

  begin                           {read_arc_hdr}
    OK := True;
    Endfile := False;
    {$I-}
    BlockRead(arc_file, bt, 1);
    if bt <> 26 then
      OK := False
    else
      begin
        BlockRead(arc_file, HdrVer, 1);
        if HdrVer < 0 then
          OK := False
        else
          if HdrVer = 0 then      { special end of file marker }
            Endfile := True
          else
            if HdrVer = 1 then
              begin
                BlockRead(arc_file, Hdr, 23);
                HdrVer := 2;
                Hdr.Length := Hdr.size
              end
            else
              BlockRead(arc_file, Hdr, 27);
      end;
    {$I+}
    if IoResult <> 0 then OK := False;
    if OK and (not Endfile) then
      Read_Arc_Hdr := True
    else
      Read_Arc_Hdr := False;
  end;



  procedure ExtractArc(var XfrName : DosFileName; var ok_to_send : Boolean);

  var
    i, block_size   : Integer;
    found, OK       : Boolean;
    XfrFile         : file;
    bt              : Byte;
    remaining       : LongInt;
    fn              : DosFileName;
    buf             : array[1..512] of Byte;

  begin                           {ExtractArc}
    SetSect(SetName);
    found := False;
    Assign(arc_file, ArcReq);
    {$I-}
    Reset(arc_file, 1) {$I+} ;
    OK := (IoResult = 0);
    ok_to_send := True;
    while (Read_Arc_Hdr) and OK and (not found) do
      begin
        i := 1;
        while (Hdr.name[i-1] <> #0) and (i < 14) do
          begin
            fn[i] := Upcase(Hdr.name[i-1]);
            i := Succ(i);
          end;
        fn[0] := Chr(Pred(i));
        if Pos('.', fn) = 0 then fn := fn+'.';
        if XfrName = fn then
          found := True
        else
          begin
            {$I-}
            Seek(arc_file, (FilePos(arc_file)+Hdr.size)) {$I+} ;
            OK := (IoResult = 0)
          end;
      end;
    if found then
      begin
        OK := True;
        remaining := Hdr.size-1;
        if (diskfree(Ord(Upcase(SetDrv[1]))-64) > remaining) then
          begin
            Assign(XfrFile, XfrName);
            {$I-}
            Rewrite(XfrFile, 1);
            buf[1] := 26;
            buf[2] := HdrVer;
            BlockWrite(XfrFile, buf, 2);
            BlockWrite(XfrFile, Hdr, 27);
            bt := 12;
            BlockWrite(XfrFile, bt, 1) {$I+} ;
            OK := (IoResult = 0);
            while ((remaining > 0) and OK) do
              begin
                block_size := min(remaining, 512);
                {$I-}
                BlockRead(arc_file, buf, block_size);
                BlockWrite(XfrFile, buf, block_size) {$I+} ;
                OK := (IoResult = 0);
                remaining := remaining-block_size;
              end;
            buf[1] := 26;
            buf[2] := 0;
            if OK then
              BlockWrite(XfrFile, buf, 2)
            else
              begin
                WriteLn(com, 'Couldn''t extract file.');
                ok_to_send := False;
              end;
          end
        else
          begin
            WriteLn(com, 'Not enough disk space to extract file.');
            ok_to_send := False;
          end;
      end
    else
      begin
        WriteLn(com, 'Couldn''t extract file.');
        ok_to_send := False
      end;
    {$I-}
    Close(arc_file);
    Close(XfrFile);
    if (not ok_to_send) then Erase(XfrFile);
    {$I+}
    OK := (IoResult = 0);
    SetSect(HomName);
  end;                            {ExtractArc}



  procedure ExtractLbr(var XfrName : DosFileName; remaining : LongInt;
                       var ok_to_send  : Boolean);

  var
    block_size      : Integer;
    XfrFile         : file;
    buf             : array[1..512] of Byte;
    OK              : Boolean;

  begin                           {ExtractLbr}
    ok_to_send := True;
    Assign(XfrFile, XfrName);
    {$I-}
    Rewrite(XfrFile, 1) {$I+} ;
    OK := (IoResult = 0);
    while ((remaining > 0) and OK) do
      begin
        block_size := min(remaining, 512);
        {$I-}
        BlockRead(libr_file, buf, block_size);
        BlockWrite(XfrFile, buf, block_size) {$I+} ;
        OK := (IoResult = 0);
        remaining := remaining-block_size;
      end;
    if (not OK) then
      begin
        WriteLn(com, 'Couldn''t extract file.');
        ok_to_send := False;
      end;
    {$I-}
    Close(XfrFile);
    if (not ok_to_send) then Erase(XfrFile) {$I+} ;
    OK := (IoResult = 0);
    SetSect(HomName);
  end;                            {ExtractLbr}

end.                              { of EXTRACT.PAS}